home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / genwrite < prev    next >
Text File  |  1993-04-02  |  9KB  |  260 lines
  1. ; File: "genwrite.scm"   (c) 1991, Marc Feeley
  2.  
  3. (define (generic-write obj display? width output)
  4.  
  5.   (define (read-macro? l)
  6.     (define (length1? l) (and (pair? l) (null? (cdr l))))
  7.     (let ((head (car l)) (tail (cdr l)))
  8.       (case head
  9.         ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail))
  10.         (else                                        #f))))
  11.  
  12.   (define (read-macro-body l)
  13.     (cadr l))
  14.  
  15.   (define (read-macro-prefix l)
  16.     (let ((head (car l)) (tail (cdr l)))
  17.       (case head
  18.         ((QUOTE)            "'")
  19.         ((QUASIQUOTE)       "`")
  20.         ((UNQUOTE)          ",")
  21.         ((UNQUOTE-SPLICING) ",@"))))
  22.  
  23.   (define (out str col)
  24.     (and col (output str) (+ col (string-length str))))
  25.  
  26.   (define (wr obj col)
  27.  
  28.     (define (wr-expr expr col)
  29.       (if (read-macro? expr)
  30.         (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
  31.         (wr-lst expr col)))
  32.  
  33.     (define (wr-lst l col)
  34.       (if (pair? l)
  35.         (let loop ((l (cdr l)) (col (wr (car l) (out "(" col))))
  36.           (and col
  37.                (cond ((pair? l) (loop (cdr l) (wr (car l) (out " " col))))
  38.                      ((null? l) (out ")" col))
  39.                      (else      (out ")" (wr l (out " . " col)))))))
  40.         (out "()" col)))
  41.  
  42.     (cond ((pair? obj)        (wr-expr obj col))
  43.           ((null? obj)        (wr-lst obj col))
  44.           ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
  45.           ((boolean? obj)     (out (if obj "#t" "#f") col))
  46.           ((number? obj)      (out (number->string obj) col))
  47.           ((symbol? obj)      (out (symbol->string obj) col))
  48.           ((procedure? obj)   (out "#[procedure]" col))
  49.           ((string? obj)      (if display?
  50.                                 (out obj col)
  51.                                 (let loop ((i 0) (j 0) (col (out "\"" col)))
  52.                                   (if (and col (< j (string-length obj)))
  53.                                     (let ((c (string-ref obj j)))
  54.                                       (if (or (char=? c #\\)
  55.                                               (char=? c #\"))
  56.                                         (loop j
  57.                                               (+ j 1)
  58.                                               (out "\\"
  59.                                                    (out (substring obj i j)
  60.                                                         col)))
  61.                                         (loop i (+ j 1) col)))
  62.                                     (out "\""
  63.                                          (out (substring obj i j) col))))))
  64.           ((char? obj)        (if display?
  65.                                 (out (make-string 1 obj) col)
  66.                                 (out (case obj
  67.                                        ((#\space)   "space")
  68.                                        ((#\newline) "newline")
  69.                                        (else        (make-string 1 obj)))
  70.                                      (out "#\\" col))))
  71.           ((input-port? obj)  (out "#[input-port]" col))
  72.           ((output-port? obj) (out "#[output-port]" col))
  73.           ((eof-object? obj)  (out "#[eof-object]" col))
  74.           (else               (out "#[unknown]" col))))
  75.  
  76.   (define (pp obj col)
  77.  
  78.     (define (spaces n col)
  79.       (if (> n 0)
  80.         (if (> n 7)
  81.           (spaces (- n 8) (out "        " col))
  82.           (out (substring "        " 0 n) col))
  83.         col))
  84.  
  85.     (define (indent to col)
  86.       (and col
  87.            (if (< to col)
  88.              (and (out (make-string 1 #\newline) col) (spaces to 0))
  89.              (spaces (- to col) col))))
  90.  
  91.     (define (pr obj col extra pp-pair)
  92.       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
  93.         (let ((result '())
  94.               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
  95.           (generic-write obj display? #f
  96.             (lambda (str)
  97.               (set! result (cons str result))
  98.               (set! left (- left (string-length str)))
  99.               (> left 0)))
  100.           (if (> left 0) ; all can be printed on one line
  101.             (out (reverse-string-append result) col)
  102.             (if (pair? obj)
  103.               (pp-pair obj col extra)
  104.               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
  105.         (wr obj col)))
  106.  
  107.     (define (pp-expr expr col extra)
  108.       (if (read-macro? expr)
  109.         (pr (read-macro-body expr)
  110.             (out (read-macro-prefix expr) col)
  111.             extra
  112.             pp-expr)
  113.         (let ((head (car expr)))
  114.           (if (symbol? head)
  115.             (let ((proc (style head)))
  116.               (if proc
  117.                 (proc expr col extra)
  118.                 (if (> (string-length (symbol->string head))
  119.                        max-call-head-width)
  120.                   (pp-general expr col extra #f #f #f pp-expr)
  121.                   (pp-call expr col extra pp-expr))))
  122.             (pp-list expr col extra pp-expr)))))
  123.  
  124.     ; (head item1
  125.     ;       item2
  126.     ;       item3)
  127.     (define (pp-call expr col extra pp-item)
  128.       (let ((col* (wr (car expr) (out "(" col))))
  129.         (and col
  130.              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
  131.  
  132.     ; (item1
  133.     ;  item2
  134.     ;  item3)
  135.     (define (pp-list l col extra pp-item)
  136.       (let ((col (out "(" col)))
  137.         (pp-down l col col extra pp-item)))
  138.  
  139.     (define (pp-down l col1 col2 extra pp-item)
  140.       (let loop ((l l) (col col1))
  141.         (and col
  142.              (cond ((pair? l)
  143.                     (let ((rest (cdr l)))
  144.                       (let ((extra (if (null? rest) (+ extra 1) 0)))
  145.                         (loop rest
  146.                               (pr (car l) (indent col2 col) extra pp-item)))))
  147.                    ((null? l)
  148.                     (out ")" col))
  149.                    (else
  150.                     (out ")"
  151.                          (pr l
  152.                              (indent col2 (out "." (indent col2 col)))
  153.                              (+ extra 1)
  154.                              pp-item)))))))
  155.  
  156.     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
  157.  
  158.       (define (tail1 rest col1 col2 col3)
  159.         (if (and pp-1 (pair? rest))
  160.           (let* ((val1 (car rest))
  161.                  (rest (cdr rest))
  162.                  (extra (if (null? rest) (+ extra 1) 0)))
  163.             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
  164.           (tail2 rest col1 col2 col3)))
  165.  
  166.       (define (tail2 rest col1 col2 col3)
  167.         (if (and pp-2 (pair? rest))
  168.           (let* ((val1 (car rest))
  169.                  (rest (cdr rest))
  170.                  (extra (if (null? rest) (+ extra 1) 0)))
  171.             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
  172.           (tail3 rest col1 col2)))
  173.  
  174.       (define (tail3 rest col1 col2)
  175.         (pp-down rest col2 col1 extra pp-3))
  176.  
  177.       (let* ((head (car expr))
  178.              (rest (cdr expr))
  179.              (col* (wr head (out "(" col))))
  180.         (if (and named? (pair? rest))
  181.           (let* ((name (car rest))
  182.                  (rest (cdr rest))
  183.                  (col** (wr name (out " " col*))))
  184.             (tail1 rest (+ col indent-general) col** (+ col** 1)))
  185.           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
  186.  
  187.     (define (pp-expr-list l col extra)
  188.       (pp-list l col extra pp-expr))
  189.  
  190.     (define (pp-LAMBDA expr col extra)
  191.       (pp-general expr col extra #f pp-expr-list #f pp-expr))
  192.  
  193.     (define (pp-IF expr col extra)
  194.       (pp-general expr col extra #f pp-expr #f pp-expr))
  195.  
  196.     (define (pp-COND expr col extra)
  197.       (pp-call expr col extra pp-expr-list))
  198.  
  199.     (define (pp-CASE expr col extra)
  200.       (pp-general expr col extra #f pp-expr #f pp-expr-list))
  201.  
  202.     (define (pp-AND expr col extra)
  203.       (pp-call expr col extra pp-expr))
  204.  
  205.     (define (pp-LET expr col extra)
  206.       (let* ((rest (cdr expr))
  207.              (named? (and (pair? rest) (symbol? (car rest)))))
  208.         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
  209.  
  210.     (define (pp-BEGIN expr col extra)
  211.       (pp-general expr col extra #f #f #f pp-expr))
  212.  
  213.     (define (pp-DO expr col extra)
  214.       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
  215.  
  216.     ; define formatting style (change these to suit your style)
  217.  
  218.     (define indent-general 2)
  219.  
  220.     (define max-call-head-width 5)
  221.  
  222.     (define max-expr-width 50)
  223.  
  224.     (define (style head)
  225.       (case head
  226.         ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA)
  227.         ((IF SET!)                   pp-IF)
  228.         ((COND)                      pp-COND)
  229.         ((CASE)                      pp-CASE)
  230.         ((AND OR)                    pp-AND)
  231.         ((LET)                       pp-LET)
  232.         ((BEGIN)                     pp-BEGIN)
  233.         ((DO)                        pp-DO)
  234.         (else                        #f)))
  235.  
  236.     (pr obj col 0 pp-expr))
  237.  
  238.   (if width
  239.     (out (make-string 1 #\newline) (pp obj 0))
  240.     (wr obj 0)))
  241.  
  242. ; (reverse-string-append l) = (apply string-append (reverse l))
  243.  
  244. (define (reverse-string-append l)
  245.  
  246.   (define (rev-string-append l i)
  247.     (if (pair? l)
  248.       (let* ((str (car l))
  249.              (len (string-length str))
  250.              (result (rev-string-append (cdr l) (+ i len))))
  251.         (let loop ((j 0) (k (- (- (string-length result) i) len)))
  252.           (if (< j len)
  253.             (begin
  254.               (string-set! result k (string-ref str j))
  255.               (loop (+ j 1) (+ k 1)))
  256.             result)))
  257.       (make-string i)))
  258.  
  259.   (rev-string-append l 0))
  260.